perm filename LAP[C,JRA]1 blob
sn#013568 filedate 1972-11-20 generic text, type T, neo UTF8
00100 (SETQ IBASE (SETQ BASE (ADD1 7)))
00200
00300 (DEFPROP LAP
00400 (LAMBDA (SL)
00500 (PROG (LOC CONLIST GEN REMOB L)
00600 (SETQ GEN (GENSYM))
00700 (SETQ CONLIST (LIST NIL))
00800 (SETQ LOC BPORG)
00900 A (COND ((NULL (SETQ L (READ))) (GO END))
01000 ((ATOM L) (DEFLOC L LOC) (GO A)))
01100 (DEPOSIT LOC (GWD L))
01200 (SETQ LOC (ADD1 LOC))
01300 (GO A)
01400 END (DEFLOC GEN LOC)
01500 EN1 (COND ((NULL (SETQ CONLIST (CDR CONLIST)))
01600 (EVAL (CONS (QUOTE REMOB) REMOB))
01700 (PUTPROP (CAR SL) (NUMVAL BPORG) (CADR SL))
01800 (RETURN (LIST (CAR SL) (SETQ BPORG LOC)))))
01900 (SETQ KLIST (CONS (CONS (CAR CONLIST) LOC) KLIST))
02000 (DEPOSIT LOC (GWD (CAR CONLIST)))
02100 (SETQ LOC (ADD1 LOC))
02200 (GO EN1)))
02300 FEXPR)
02400
02500 (DEFPROP TYPE (LAMBDA (X) (COND ((NUMBERP X) (CADR X)))) EXPR)
02600
02700 (DEFPROP GWD
02800 (LAMBDA (X)
02900 (PROG (WRD FLD)
03000 (SETQ FLD (QUOTE ((22 . -1) (27 . 17) (0 . 777777) (22 . 777777))))
03100 (SETQ WRD 0)
03200 (MAPCAR
03300 (FUNCTION (LAMBDA (ZZ)
03400 (PROG2 (SETQ WRD
03500 (PLUS WRD
03600 (LSH (BOOLE 1
03700 (CDAR FLD)
03800 (LAPEVAL ZZ))
03900 (CAAR FLD))))
04000 (SETQ FLD (CDR FLD)))))
04100 X)
04200 (RETURN WRD)))
04300 EXPR)
04400
04500 (DEFPROP LAPEVAL
04600 (LAMBDA (X)
04700 (COND ((NUMBERP X) X)
04800 ((ATOM X) (GVAL X))
04900 ((MEMBER (CAR X) (QUOTE (E QUOTE)))
05000 (MAKNUM (COND ((OR (NOT (ATOM (SETQ X (CADR X))))
05100 (AND (NUMBERP X) (NOT (EQ (PLUS X 0) X)))
05200 (EQ (CAR (EXPLODE X)) (QUOTE /⊗)))
05300 (PROG (Y)
05400 (SETQ Y QLIST)
05500 A (COND ((NULL Y)
05600 (RETURN (CAR (SETQ QLIST
05700 (CONS X QLIST)))))
05800 ((AND (EQUAL X (CAR Y))
05900 (EQ (TYPE X) (TYPE (CAR Y))))
06000 (RETURN (CAR Y))))
06100 (SETQ Y (CDR Y))
06200 (GO A)))
06300 (T X))
06400 (QUOTE FIXNUM)))
06500 ((EQ (CAR X) (QUOTE SPECIAL))
06600 (COND ((NULL (GET (CADR X) (QUOTE VALUE)))
06700 (PUTPROP (CADR X) (LIST NIL) (QUOTE VALUE))))
06800 (MAKNUM (GET (CADR X) (QUOTE VALUE)) (QUOTE FIXNUM)))
06900 ((EQ (CAR X) (QUOTE C))
07000 (PROG (N CPTR)
07100 (SETQ CPTR KLIST)
07200 L11 (COND ((NULL CPTR) (GO L12))
07300 ((EQUAL (CDR X) (CAAR CPTR)) (RETURN (CDAR CPTR))))
07400 (SETQ CPTR (CDR CPTR))
07500 (GO L11)
07600 L12 (GVAL GEN)
07700 (SETQ N 0)
07800 (SETQ CPTR CONLIST)
07900 A (COND ((NULL (CDR CPTR)) (RPLACD CPTR (LIST (CDR X)))))
08000 (COND ((EQUAL (CDR X) (CADR CPTR)) (RETURN N)))
08100 (SETQ N (ADD1 N))
08200 (SETQ CPTR (CDR CPTR))
08300 (GO A)))
08400 (T (PLUS (LAPEVAL (CAR X)) (LAPEVAL (CDR X))))))
08500 EXPR)
08600
08700 (DEFPROP DEFLOC
08800 (LAMBDA (SYM VAL)
08900 (PROG (Z)
09000 (SETQ REMOB (CONS SYM REMOB))
09100 (COND ((SETQ Z (GET SYM (QUOTE UNDEF))) (GO PATCH)))
09200 A (RETURN (PUTPROP SYM VAL (QUOTE SYM)))
09300 PATCH(COND ((NULL Z) (RPLACD SYM (CDDDR SYM)) (GO A)))
09400 (DEPOSIT (CAR Z) (PLUS (EXAMINE (CAR Z)) VAL))
09500 (SETQ Z (CDR Z))
09600 (GO PATCH)))
09700 EXPR)
09800
09900 (DEFPROP DEFSYM (LAMBDA (SYM VAL) (PUTPROP SYM VAL (QUOTE SYM))) EXPR)
10000
10100 (DEFPROP GVAL
10200 (LAMBDA (SYM)
10300 (COND ((GET SYM (QUOTE SYM)))
10400 ((GET SYM (QUOTE VALUE)) (MAKNUM SYM (QUOTE FIXNUM)))
10500 (T (PUTPROP SYM
10600 (CONS LOC (GET SYM (QUOTE UNDEF)))
10700 (QUOTE UNDEF))
10800 0)))
10900 EXPR)
11000
11100 (DEFPROP OPS
11200 (LAMBDA (L)
11300 (PROG NIL
11400 A (COND ((NULL L) (RETURN T)))
11500 (DEFSYM (CAAR L) (CADAR L))
11600 (SETQ L (CDR L))
11700 (GO A)))
11800 FEXPR)
11900
12000 (DEFPROP REMLAP
12100 (LAMBDA NIL
12200 (PROG (Z)
12300 (SETQ Z
12400 (QUOTE (LAP LAPEVAL
12500 GWD
12600 DEFLOC
12700 DEFSYM
12800 REMLAP
12900 ILAP
13000 GVAL
13100 TYPE)))
13200 A (COND ((NULL Z) (GO B)))
13300 (REMPROP (CAR Z) (QUOTE EXPR))
13400 (REMPROP (CAR Z) (QUOTE FEXPR))
13500 (SETQ Z (CDR Z))
13600 (GO A)
13700 B (REMPROP (QUOTE REMLAP) (QUOTE EXPR))))
13800 EXPR)
13900
14000 (OPS
14100 (ADD 270000)
14200 (CALL 34000)
14300 (CALLF 36000)
14400 (CALLF@ 36020)
14500 (CAIE 302000)
14600 (CAIN 306000)
14700 (CAME 312000)
14800 (CAMN 316000)
14900 (CLEARB 403000)
15000 (CLEARM 402000)
15100 (DPB 137000)
15200 (EXCH 250000)
15300 (HLLZS@ 513020)
15400 (HLRZ 554000)
15500 (HLRZ@ 554020)
15600 (HRLM 506000)
15700 (HRLM@ 506020)
15800 (HRRM 542000)
15900 (HRRZS@ 553020)
16000 (HRRZ 550000)
16100 (HRRM@ 542020)
16200 (HRRZ@ 550020)
16300 (JCALL 35000)
16400 (JCALLF 37000)
16500 (JCALLF@ 37020)
16600 (JRST 254000)
16700 (JSP 265000)
16800 (JUMPE 322000)
16900 (JUMPN 326000)
17000 (MOVE 200000)
17100 (MOVEI 201000)
17200 (MOVEM 202000)
17300 (MOVNI 211000)
17400 (P 14)
17500 (POP 262000)
17600 (POPJ 263000)
17700 (PUSH 261000)
17800 (PUSHJ 260000)
17900 (SOJE 362000)
18000 (SOJN 366000)
18100 (SUB 274000)
18200 (TDZA 634000))
18300
18400 (COND ((NULL (GET (QUOTE QLIST) (QUOTE VALUE))) (SETQ QLIST NIL)))
18500
18600 (COND ((NULL (GET (QUOTE KLIST) (QUOTE VALUE))) (SETQ KLIST NIL)))
18700
18800 (SETQ SAVEBPORG BPORG)
18900
19000 (SETQ LAPORG BPEND)
19100
19200 (SETQ SAVELAPORG (SETQ BPORG (*DIF BPEND 500)))
19300
19400 (LAP GWD SUBR)
19500 (PUSH P (C 0))
19600 (PUSH P 1)
19700 (PUSHJ P G0123)
19800 (137000 1 (C 222200 0 -1 P))
19900 (PUSHJ P G0123)
20000 (242000 1 27)
20100 (436000 1 -1 P)
20200 (PUSHJ P G0123)
20300 (137000 1 (C 2200 0 -1 P))
20400 (PUSHJ P G0123)
20500 (514000 1 1)
20600 (436000 1 -1 P)
20700 G0124 (POP P 1)
20800 (POP P 1)
20900 (JRST 0 FIX1A)
21000 G0125 (POP P 1)
21100 (JRST 0 G0124)
21200 G0123 (MOVE 2 -1 P)
21300 (JUMPE 2 G0125)
21400 (HLRZ 1 0 2)
21500 (HRRZ 2 0 2)
21600 (MOVEM 2 -1 P)
21700 (CALL 1 (E LAPEVAL))
21800 (JRST 0 NUMVAL)
21900 NIL
22000
22100
22200 (LAP LAP FSUBR)
22300 (JSP 6 SPECBIND)
22400 (0 0 (SPECIAL LOC))
22500 (0 0 (SPECIAL CONLIST))
22600 (0 0 (SPECIAL GEN))
22700 (0 0 (SPECIAL REMOB))
22800 (PUSH P 1)
22900 (CALL 0 (E GENSYM))
23000 (MOVEM 1 (SPECIAL GEN))
23100 (MOVEI 1 (QUOTE NIL))
23200 (CALL 1 (E NCONS))
23300 (MOVEM 1 (SPECIAL CONLIST))
23400 (MOVE 2 (SPECIAL BPORG))
23500 (MOVEM 2 (SPECIAL LOC))
23600 (PUSH P (C 0 0 (QUOTE NIL)))
23700 G0001 (CALL 0 (E READ))
23800 (MOVEM 1 0 P)
23900 (JUMPE 1 G0002)
24000 (CALL 1 (E ATOM))
24100 (JUMPE 1 G0011)
24200 (MOVE 2 (SPECIAL LOC))
24300 (MOVE 1 0 P)
24400 (CALL 2 (E DEFLOC))
24500 (JRST 0 G0001)
24600 G0011 (MOVE 1 0 P)
24700 (PUSH P (SPECIAL LOC))
24800 (CALL 1 (E GWD))
24900 (MOVE 2 1)
25000 (POP P 1)
25100 (CALL 2 (E DEPOSIT))
25200 (MOVE 1 (SPECIAL LOC))
25300 (CALL 1 (E ADD1))
25400 (MOVEM 1 (SPECIAL LOC))
25500 (MOVE 2 (SPECIAL LAPORG))
25600 (CALL 2 (E *LESS))
25700 (JUMPN 1 G0001)
25800 (MOVEI 1 (QUOTE (BINARY PROGRAM SPACE EXCEEDED)))
25900 (CALL 1 (E PRINT))
26000 (CALL 0 (E ERR))
26100 (JRST 0 G0001)
26200 G0002 (MOVE 2 (SPECIAL LOC))
26300 (MOVE 1 (SPECIAL GEN))
26400 (CALL 2 (E DEFLOC))
26500 G0003 (HRRZ@ 1 (SPECIAL CONLIST))
26600 (MOVEM 1 (SPECIAL CONLIST))
26700 (JUMPN 1 G0022)
26800 (MOVE 1 (SPECIAL REMOB))
26900 (CALL 17 (E REMOB))
27000 (HLRZ@ 1 -1 P)
27100 (PUSH P 1)
27200 (MOVE 1 (SPECIAL BPORG))
27300 (CALL 1 (E NUMVAL))
27400 (HRRZ@ 3 -2 P)
27500 (HLRZ@ 3 3)
27600 (MOVE 2 1)
27700 (POP P 1)
27800 (CALL 3 (E PUTPROP))
27900 (MOVE 1 (SPECIAL LOC))
28000 (MOVEM 1 (SPECIAL BPORG))
28100 (CALL 1 (E NCONS))
28200 (HLRZ@ 2 -1 P)
28300 (CALL 2 (E XCONS))
28400 (JRST 0 G0004)
28500 G0022 (MOVE 2 (SPECIAL LOC))
28600 (HLRZ@ 1 (SPECIAL CONLIST))
28700 (CALL 2 (E CONS))
28800 (MOVE 2 (SPECIAL KLIST))
28900 (CALL 2 (E CONS))
29000 (MOVEM 1 (SPECIAL KLIST))
29100 (HLRZ@ 1 (SPECIAL CONLIST))
29200 (PUSH P (SPECIAL LOC))
29300 (CALL 1 (E GWD))
29400 (MOVE 2 1)
29500 (POP P 1)
29600 (CALL 2 (E DEPOSIT))
29700 (MOVE 1 (SPECIAL LOC))
29800 (CALL 1 (E ADD1))
29900 (MOVEM 1 (SPECIAL LOC))
30000 (JRST 0 G0003)
30100 G0004 (SUB P (C 0 0 2 2))
30200 (JRST 0 SPECSTR)
30300 NIL
30400
30500
30600 (LAP LAPEVAL SUBR)
30700 (PUSH P 1)
30800 (CALL 1 (E NUMBERP))
30900 (JUMPE 1 G0006)
31000 (MOVE 1 0 P)
31100 (JRST 0 G0005)
31200 G0006 (MOVE 1 0 P)
31300 (CALL 1 (E ATOM))
31400 (JUMPE 1 G0008)
31500 (MOVE 1 0 P)
31600 (CALL 1 (E GVAL))
31700 (JRST 0 G0005)
31800 G0008 (MOVEI 2 (QUOTE (E QUOTE)))
31900 (HLRZ@ 1 0 P)
32000 (CALL 2 (E MEMBER))
32100 (JUMPE 1 G0011)
32200 (HRRZ@ 1 0 P)
32300 (HLRZ@ 1 1)
32400 (MOVEM 1 0 P)
32500 (CALL 1 (E ATOM))
32600 (JUMPE 1 G0016)
32700 (MOVE 1 0 P)
32800 (CALL 1 (E NUMBERP))
32900 (JUMPE 1 G0019)
33000 (MOVEI 2 (QUOTE 0))
33100 (MOVE 1 0 P)
33200 (CALL 2 (E *PLUS))
33300 (CAME 1 0 P)
33400 (JRST 0 G0016)
33500 G0019 (MOVE 1 0 P)
33600 (CALL 1 (E EXPLODE))
33700 (HLRZ@ 2 1)
33800 (CAIE 2 (QUOTE /⊗))
33900 (JRST 0 G0015)
34000 G0016 (PUSH P (SPECIAL QLIST))
34100 G0001 (MOVE 1 0 P)
34200 (JUMPN 1 G0028)
34300 (MOVE 2 (SPECIAL QLIST))
34400 (MOVE 1 -1 P)
34500 (CALL 2 (E CONS))
34600 (MOVEM 1 (SPECIAL QLIST))
34700 (HLRZ@ 1 1)
34800 (JRST 0 G0024)
34900 G0028 (HLRZ@ 2 1)
35000 (MOVE 1 -1 P)
35100 (CALL 2 (E EQUAL))
35200 (JUMPE 1 G0032)
35300 (MOVE 1 -1 P)
35400 (CALL 1 (E TYPE))
35500 (PUSH P 1)
35600 (HLRZ@ 1 -1 P)
35700 (CALL 1 (E TYPE))
35800 (POP P 2)
35900 (CAME 1 2)
36000 (JRST 0 G0032)
36100 (HLRZ@ 1 0 P)
36200 (JRST 0 G0024)
36300 G0032 (HRRZ@ 1 0 P)
36400 (MOVEM 1 0 P)
36500 (JRST 0 G0001)
36600 G0024 (SUB P (C 0 0 1 1))
36700 (JRST 0 G0014)
36800 G0015 (MOVE 1 0 P)
36900 G0045
37000 G0014 (MOVEI 2 (QUOTE FIXNUM))
37100 (CALL 2 (E MAKNUM))
37200 (JRST 0 G0005)
37300 G0011 (HLRZ@ 1 0 P)
37400 (CAIE 1 (QUOTE SPECIAL))
37500 (JRST 0 G0049)
37600 (MOVEI 2 (QUOTE VALUE))
37700 (HRRZ@ 1 0 P)
37800 (HLRZ@ 1 1)
37900 (CALL 2 (E GET))
38000 (JUMPN 1 G0052)
38100 (CALL 1 (E NCONS))
38200 (MOVEI 3 (QUOTE VALUE))
38300 (MOVE 2 1)
38400 (HRRZ@ 1 0 P)
38500 (HLRZ@ 1 1)
38600 (CALL 3 (E PUTPROP))
38700 G0052 (MOVEI 2 (QUOTE VALUE))
38800 (HRRZ@ 1 0 P)
38900 (HLRZ@ 1 1)
39000 (CALL 2 (E GET))
39100 (MOVEI 2 (QUOTE FIXNUM))
39200 (CALL 2 (E MAKNUM))
39300 (JRST 0 G0005)
39400 G0049 (CAIE 1 (QUOTE C))
39500 (JRST 0 G0062)
39600 (PUSH P (SPECIAL KLIST))
39700 (PUSH P (C 0 0 (QUOTE NIL)))
39800 G0002 (MOVE 1 -1 P)
39900 (JUMPE 1 G0003)
40000 (HLRZ@ 2 1)
40100 (HLRZ@ 2 2)
40200 (HRRZ@ 1 -2 P)
40300 (CALL 2 (E EQUAL))
40400 (JUMPE 1 G0068)
40500 (HLRZ@ 1 -1 P)
40600 (HRRZ@ 1 1)
40700 (JRST 0 G0064)
40800 G0068 (HRRZ@ 1 -1 P)
40900 (MOVEM 1 -1 P)
41000 (JRST 0 G0002)
41100 G0003 (MOVE 1 (SPECIAL GEN))
41200 (CALL 1 (E GVAL))
41300 (MOVEI 2 (QUOTE 0))
41400 (MOVE 3 (SPECIAL CONLIST))
41500 (MOVEM 3 -1 P)
41600 (MOVEM 2 0 P)
41700 G0004 (HRRZ@ 1 -1 P)
41800 (JUMPN 1 G0079)
41900 (HRRZ@ 1 -2 P)
42000 (CALL 1 (E NCONS))
42100 (HRRM@ 1 -1 P)
42200 G0079 (HRRZ@ 2 -1 P)
42300 (HLRZ@ 2 2)
42400 (HRRZ@ 1 -2 P)
42500 (CALL 2 (E EQUAL))
42600 (JUMPE 1 G0085)
42700 (MOVE 1 0 P)
42800 (JRST 0 G0064)
42900 G0085 (MOVE 1 0 P)
43000 (CALL 1 (E ADD1))
43100 (MOVEM 1 0 P)
43200 (HRRZ@ 1 -1 P)
43300 (MOVEM 1 -1 P)
43400 (JRST 0 G0004)
43500 G0064 (SUB P (C 0 0 2 2))
43600 (JRST 0 G0005)
43700 G0062 (HLRZ@ 1 0 P)
43800 (CALL 1 (E LAPEVAL))
43900 (PUSH P 1)
44000 (HRRZ@ 1 -1 P)
44100 (CALL 1 (E LAPEVAL))
44200 (POP P 2)
44300 (CALL 2 (E *PLUS))
44400 G0095
44500 G0005 (SUB P (C 0 0 1 1))
44600 (POPJ P)
44700 NIL
44800
44900
45000 (LAP DEFLOC SUBR)
45100 (PUSH P 2)
45200 (MOVE 2 (SPECIAL REMOB))
45300 (PUSH P 1)
45400 (CALL 2 (E CONS))
45500 (MOVEM 1 (SPECIAL REMOB))
45600 (PUSH P (C 0 0 (QUOTE NIL)))
45700 (MOVEI 2 (QUOTE UNDEF))
45800 (MOVE 1 -1 P)
45900 (CALL 2 (E GET))
46000 (MOVEM 1 0 P)
46100 (JUMPN 1 G0002)
46200 G0001 (MOVEI 3 (QUOTE SYM))
46300 (MOVE 2 -2 P)
46400 (MOVE 1 -1 P)
46500 (CALL 3 (E PUTPROP))
46600 (JRST 0 G0003)
46700 G0002 (MOVE 1 0 P)
46800 (JUMPN 1 G0013)
46900 (HRRZ@ 2 -1 P)
47000 (HRRZ@ 2 2)
47100 (HRRZ@ 2 2)
47200 (HRRM@ 2 -1 P)
47300 (JRST 0 G0001)
47400 G0013 (HLRZ@ 1 0 P)
47500 (PUSH P 1)
47600 (CALL 1 (E EXAMINE))
47700 (MOVE 2 -3 P)
47800 (CALL 2 (E *PLUS))
47900 (MOVE 2 1)
48000 (POP P 1)
48100 (CALL 2 (E DEPOSIT))
48200 (HRRZ@ 1 0 P)
48300 (MOVEM 1 0 P)
48400 (JRST 0 G0002)
48500 G0003 (SUB P (C 0 0 3 3))
48600 (POPJ P)
48700 NIL
48800
48900 (LAP DEFSYM SUBR)
49000 (MOVEI 3 (QUOTE SYM))
49100 (JCALL 3 (E PUTPROP))
49200 NIL
49300
49400
49500 (LAP GVAL SUBR)
49600 (PUSH P 1)
49700 (MOVEI 2 (QUOTE SYM))
49800 (CALL 2 (E GET))
49900 (JUMPN 1 G0001)
50000 (MOVEI 2 (QUOTE VALUE))
50100 (MOVE 1 0 P)
50200 (CALL 2 (E GET))
50300 (JUMPE 1 G0003)
50400 (MOVEI 2 (QUOTE FIXNUM))
50500 (MOVE 1 0 P)
50600 (CALL 2 (E MAKNUM))
50700 (JRST 0 G0001)
50800 G0003 (MOVEI 2 (QUOTE UNDEF))
50900 (MOVE 1 0 P)
51000 (CALL 2 (E GET))
51100 (MOVE 2 (SPECIAL LOC))
51200 (CALL 2 (E XCONS))
51300 (MOVEI 3 (QUOTE UNDEF))
51400 (MOVE 2 1)
51500 (MOVE 1 0 P)
51600 (CALL 3 (E PUTPROP))
51700 (MOVEI 1 (QUOTE 0))
51800 G0006
51900 G0001 (SUB P (C 0 0 1 1))
52000 (POPJ P)
52100 NIL
52200
52300
52400 (LAP TYPE SUBR)
52500 (PUSH P 1)
52600 (CALL 1 (E NUMBERP))
52700 (JUMPE 1 G0002)
52800 (HRRZ@ 1 0 P)
52900 (HLRZ@ 1 1)
53000 G0002 (SUB P (C 0 0 1 1))
53100 (POPJ P)
53200 NIL
53300
53400
53500 (SETQ KLIST NIL)
53600
53700 (SETQ LAPORG SAVELAPORG)
53800
53900 (SETQ BPORG SAVEBPORG)
54000
54100 (REMLAP)
54200
54300 (MAPC (FUNCTION (LAMBDA (X) (REMPROP X (QUOTE MACRO))))
54400 (QUOTE (DEFSYM LAP OPS)))
54500